Pascal Super Library/Pascal Super Library (CW International)(1997).bin/EDIT_UTL/TRIVED09/SERIO.PAS

Pascal/Delphi Source File | 1995-04-16 | 16KB | 863 lines

{serio.pas begins}

{serio:  header begins}

{

serio.pas - nonconsole input/output routines - modified slightly from rusnews

Russell Schulz - [e-mail] (940327)

Copyright 1995 Russell Schulz

this code is not in the Public Domain

version 3

permission is granted to use these routines in any application regardless
of commercial status as long as the author of these routines assumes no
liability for any damages whatsoever for any reason.  have fun.

assumes a fossil/int14 driver (if the nonconsole routines will ever be used)

shortcomings:
  very simplistic
  not a nice tpascal-type text file driver
  minimal ansi/vt100 hard-coded in for nonconsole routines

requires:

  units:
    uses dos,crt;  possibly mouse if mouse is $define'd

  variables:
      console: boolean;
      port: integer;  0=com1,1=com2,(untested 2=com3,3=com4)
        note that this is fossil/bios convention, not dos convention!
      shadow: integer; 0 for no shadowing to screen, n>0 for n/1000 sec delay
      eightbitclean: boolean;
      highcolor: integer;  0-255
      lowcolor: integer;  0-255
      readlnecho: boolean;

    if mapkey is defined
      mainmap: array[char] of char;  (if mapkeys is defined)

    if timeout is defined
      minstart: integer;  result of mitoday() at start
      minlastinput: integer;  initialize to mitoday() at start
      minutestorun: integer;  number of minutes to run, or -1 for no limit
      idleminutes: integer;  number of idle minutes allowed
      didtimeout: boolean;  initialize to false at start

  procedures:
    mousehide,mouseshow;  if mouse is $define'd

  possible defines:
    debug - print debug info on startup
    consoleoverride - to allow console keyboard input to override serial
    timeout - use timeout functions
    mouse - use rodent in a simplistic manner
    pgdnbecomesgt - translate pgdn to greater than -- otherwise space
    xwritelnafterxreadln - otherwise up to caller
    mapkeys - translation vector is in mainmap[] -- char c gets changed
      to char mainmap[c] before being returned

interface:

  functions:
    xkeypressed: boolean;
    xreadkey: char;

  procedures:
    portengage;
    portdisengage;
    portspeed(speed);
    xwrites(s);
    xwritei(i);
    xwriteiw(i,w);
    xwritess(s,s);
    xwritesss(s,s,s);
    xwriteln;
    xwritelns(s);
    xwritelnss(s,s);
    xwritelnsss(s,s,s);
    xgotoxy(x,y);
    xwritexy(x,y,s);
    xclreol;
    xclreolxy(x,y);
    xclrscr;
    xreadlns(s,maxlen,keepcurrent);
    xreadlnsp(s,maxlen,keepcurrent);
    xhighvideo;
    xlowvideo;
    xwritehighlights(s: string);

}

{$ifndef timeout}
  const
    didtimeout=false;
{$endif}

{$ifdef timeout}

function mitoday: integer; {minutes into today}

var
  h,m,s,s00: word;

begin
  gettime(h,m,s,s00);
  mitoday := 60*h+m;
end;

{$endif}

{$ifndef mouse}

procedure mousehide;

begin end;

procedure mouseshow;

begin end;

{$endif}

{serio:  header ends}

{serio:  actual serial i/o stuff begins}

procedure portengage;

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 4;
  regs.bx := 0;
  intr($14,regs);

{$ifdef debug}
  writeln('serio:  portengage');
  writeln('regs.ax=',regs.ax,' (6484 for a fossil driver)');
  writeln('regs.bl=',regs.bl,' highest function supported');
  writeln('regs.bh=',regs.bh,' version of fossil spec');
{$endif}

end;

procedure portdisengage;

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 5;
  intr($14,regs);
end;

procedure portspeed(speed: longint);

var
  regs: registers;
  speedbyte: byte;

begin
  speedbyte := 2;

  case speed of
      600: speedbyte := 3;
     1200: speedbyte := 4;
     2400: speedbyte := 5;
     4800: speedbyte := 6;
     9600: speedbyte := 7;
    19200: speedbyte := 0;
{   38400: speedbyte := 1; }  {supported by some fossils}
  end;
  speedbyte := speedbyte shl 5;

  regs.dx := port;
  regs.ah := 0;
  regs.al := speedbyte or 3;
  intr($14,regs);
end;

procedure noncwritec(c: char);

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 1;
  regs.al := ord(c);
  intr($14,regs);
end;

function noncreadc: char;

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 2;
  intr($14,regs);
  noncreadc := chr(regs.al);
end;

function noncinready: boolean;

var
  regs: registers;

begin
  regs.dx := port;
  regs.ah := 3;
  intr($14,regs);
  noncinready := odd(regs.ah);
end;

{serio:  actual serial i/o stuff ends}

{serio:  initial output procedures begin}

procedure xwrites(s: string);

var
  i: integer;

begin
  if console then
    begin
      mousehide;
      write(s);
      mouseshow;
    end
  else
    begin
      for i := 1 to length(s) do
        noncwritec(s[i]);
      if shadow>0 then
        begin
          write(s);
{$ifndef nocrtunit}
          delay(shadow);
{$endif}
        end;
    end;
end;

procedure xwritei(i: integer);

var
  s: string;

begin
  if console then
    begin
      mousehide;
      write(i);
      mouseshow;
    end
  else
    begin
      str(i,s);
      xwrites(s);
    end;
end;

procedure xwriteiw(i,w: integer);

var
  s: string;

begin
  if console then
    begin
      mousehide;
      write(i:w);
      mouseshow;
    end
  else
    begin
      str(i:w,s);
      xwrites(s);
    end;
end;

procedure xwritess(s1,s2: string);

begin
  xwrites(s1);
  xwrites(s2);
end;

procedure xwritesss(s1,s2,s3: string);

begin
  xwrites(s1);
  xwrites(s2);
  xwrites(s3);
end;

procedure xwriteln;

begin
  if console then
    begin
      mousehide;
      writeln;
      mouseshow;
    end
  else
    xwritess(chr(13),chr(10));
end;

procedure xwritelns(s: string);

begin
  xwrites(s);
  xwriteln;
end;

procedure xwritelnss(s1,s2: string);

begin
  xwrites(s1);
  xwrites(s2);
  xwriteln;
end;

procedure xwritelnsss(s1,s2,s3: string);

begin
  xwrites(s1);
  xwrites(s2);
  xwrites(s3);
  xwriteln;
end;

{serio:  initial output procedures end}

{serio:  functions begin}

function xkeypressed: boolean;

var
  result: boolean;
  minnow: integer;

begin
  result := false;

{$ifdef timeout}
  didtimeout := false;
{$endif}

  if console then
    begin
{$ifdef mouse}
      if hasmouse then
        result := keypressed or (mousevent.event<>0)
      else
        result := keypressed;
{$else}
{$ifdef nocrtunit}
      writeln('no crt unit -- cannot use xkeypresssed');
      halt(1);
{$else}
      result := keypressed;
{$endif}
{$endif}
    end
  else
    begin

{check for timeout _before_ checking if a key is ready - modems can spew}

{$ifdef timeout}

      minnow := mitoday;
      if minnow<minstart then
        inc(minnow,24*60);

      if (minutestorun>=0) and (minnow-minstart>=minutestorun) then
        begin
          xwriteln;
          xwritelns('time up');
          xwriteln;
          halt(2);
        end;

      if minnow<minlastinput then
        inc(minnow,24*60);

      if minnow-minlastinput>idleminutes then
        begin
{$ifdef timeoutreturnscr}
          didtimeout := true;
          result := true;
{$else}
          xwriteln;
          xwritelns('idle timeout');
          xwriteln;
          halt(2);
{$endif}
        end;

{$endif}

{$ifdef consoleoverride}

{$ifdef mouse}
      if hasmouse then
        result := result or noncinready or keypressed or (mousevent.event<>0)
      else
        result := result or noncinready or keypressed;
{$else}
      result := result or noncinready or keypressed;
{$endif}

{$else}
      result := result or noncinready;
{$endif}

    end;

  xkeypressed := result;
end;

function xreadkeyextended(forcecolumn: integer; forcerow: integer;
 beginrow, endrow: integer): char;

var
  result: char;

{$ifdef mouse}
  regs: registers;
  wasx, wasy: byte;
  newx, newy: byte;
{$endif}

begin
  if console then
    begin

{ ignore function keys, alt keys, numeric pad keys - translate to ' ' }

      repeat

{$ifdef mouse}

        repeat
        { nothing - we're on the console }
        until xkeypressed;

        if keypressed then
          begin
            result := readkey;
          end
        else
          begin
            wasx := wherex;
            wasy := wherey;

            newx := 1+(mousevent.horiz div 8);
            newy := 1+(mousevent.vert div 8);

            if forcecolumn<>0 then
              newx := forcecolumn;
            if forcerow<>0 then
              newy := forcerow;

            if (newy>=beginrow) and (newy<=endrow) then
              newx := 1;

            gotoxy(newx,newy);

{read character from screen}
            regs.ah := 8;
            regs.bh := 0;
            intr($10,regs);

            result := chr(regs.al);

            gotoxy(wasx,wasy);
            mousevent.event := 0;
          end;

{$else}

{$ifdef nocrtunit}
        writeln('cannot use xreadkey without crt unit');
        halt(1);
{$else}
        result := readkey;
{$endif}

{$endif}

{$ifndef nocrtunit}
        if (result=#0) and keypressed then
          begin
            result := readkey;

{ change these extended keys: }

{    2nd Char key pressed    code returned }
{    -------- -----------    ------------- }
{    I  73    PgUp           <             }
{    Q  81    PgDn           space or >    }
{    G  71    Home           ^             }
{    O  79    End            $             }
{    ;  59    F1             ?             }
{    K  75    left arrow     backspace     }
{    $  36    alt-J          !             }

            if result='I' then
              result := '<'
{$ifdef pgdnbecomesgt}
            else if result='Q' then
              result := '>'
{$else}
            else if result='Q' then
              result := ' '
{$endif}
            else if result='G' then
              result := '^'
            else if result='O' then
              result := '$'
            else if result=';' then
              result := '?'
            else if result='K' then
              result := #8
            else if result='$' then
              result := '!'
            else

{ ignore other extended keys }

              result := #0;

          end;
{$endif}

      until result<>#0;
    end
  else
    begin
      while not xkeypressed do
        ;

      if didtimeout then
        begin
{$ifdef timeout}
          didtimeout := false;
{$endif}
          result := #13;
        end
      else
        begin

{$ifdef consoleoverride}
          if keypressed then
            result := readkey
          else
{$endif}
            result := noncreadc;

        end;

    end;

{$ifdef mapkeys}
  result := mainmap[result];
{$endif}

  xreadkeyextended := result;
end;

function xreadkey: char;

begin
  xreadkey := xreadkeyextended(0,0,0,0);
end;

{serio:  functions end}

{serio:  procedures begin}

procedure xgotoxy(x,y: integer);

begin
  if console then
    begin
      mousehide;
{$ifdef nocrtunit}
      writeln('cannot use xgotoxy without crt unit');
      halt(1);
{$else}
      gotoxy(x,y);
{$endif}
      mouseshow;
    end
  else
    begin
      xwritess(#27,'[');
      xwritei(y);
      xwrites(';');
      xwritei(x);
      xwrites('f');
    end;
end;

procedure xwritexy(x,y: integer; s: string);

begin
  xgotoxy(x,y);
  xwrites(s);
end;

procedure xclreol;

begin
  if console then
    begin
      mousehide;
{$ifdef nocrtunit}
      writeln('cannot use xclreol without crt unit');
      halt(1);
{$else}
      clreol;
{$endif}
      mouseshow;
    end
  else
    xwritess(#27,'[0K');
end;

procedure xclreolxy(x,y: integer);

begin
  xgotoxy(x,y);
  xclreol;
end;

procedure xclrscr;

begin
  if console then
    begin
      mousehide;
{$ifdef nocrtunit}
      writeln('cannot use xclrscr without crt unit');
      halt(1);
{$else}
      clrscr;
{$endif}
      mouseshow;
    end
  else
    begin
      xwritess(#27,'[2J');
      xgotoxy(1,1);
    end;
end;

procedure xreadlns(var s: string; maxlen: integer; keepcurrent: boolean);

var
  result: string;
  len: integer;
  c: char;

begin
  if keepcurrent then
    result := s
  else
    result := '';
  len := length(result);
  xwrites(result);
  repeat
    c := xreadkey;
    if (c=#127) or (c=#8) then
      begin
        if length(result)>0 then
          begin
            if readlnecho then
              xwritesss(#8,' ',#8);
            dec(len);
            if len=0 then
              result := ''
            else
              result := copy(result,1,len);
          end;
      end
    else if (c=#13) then
      begin
{$ifdef xwritelnafterxreadln}
        xwriteln;
{$endif}
      end
    else if (c=#21) then   { control-U }
      begin
        while len>0 do
          begin
            if readlnecho then
              xwritesss(#8,' ',#8);
            dec(len);
          end;
        result := '';
      end
    else if (ord(c)>=32) and (eightbitclean or (ord(c)<128))
     and (len<maxlen) then
      begin
        inc(len);
        result := result+c;
        if readlnecho then
          begin
            if console then
              begin
                mousehide;
                write(c);
                mouseshow;
              end
            else
              noncwritec(c);
          end;
      end
  until c=#13;
  s := result;
end;

procedure xreadlnsp(var s: string; maxlen: integer; keepcurrent: boolean);

{readln, can end with SPACE or RETURN}

var
  result: string;
  len: integer;
  c: char;

begin
  if keepcurrent then
    result := s
  else
    result := '';
  len := length(result);
  xwrites(result);
  repeat
    c := xreadkey;
    if (c=#127) or (c=#8) then
      begin
        if length(result)>0 then
          begin
            if readlnecho then
              xwritesss(#8,' ',#8);
            dec(len);
            if len=0 then
              result := ''
            else
              result := copy(result,1,len);
          end;
      end
    else if (c=#13) or (c=' ') then
      begin
{$ifdef xwritelnafterxreadln}
        xwriteln;
{$endif}
      end
    else if (c=#21) then   { control-U }
      begin
        while len>0 do
          begin
            if readlnecho then
              xwritesss(#8,' ',#8);
            dec(len);
          end;
        result := '';
      end
    else if (ord(c)>=32) and (eightbitclean or (ord(c)<128))
     and (len<maxlen) then
      begin
        inc(len);
        result := result+c;
        if readlnecho then
          begin
            if console then
              begin
                mousehide;
                write(c);
                mouseshow;
              end
            else
              noncwritec(c);
          end;
      end
  until (c=#13) or (c=' ');
  s := result;
end;

procedure xhighvideo;

{color is 0-15, background is 0-7}

begin
  if console then
    begin
{$ifdef nocrtunit}
      writeln('cannot use xhighvideo without crt unit');
      halt(1);
{$else}
      textcolor(highcolor and $f);
      textbackground(highcolor shr 4);
{$endif}
    end
  else
    xwritess(#27,'[7m');
end;

procedure xlowvideo;

{color is 0-15, background is 0-7}

begin
  if console then
    begin
{$ifdef nocrtunit}
      writeln('cannot use xlowvideo without crt unit');
      halt(1);
{$else}
      textcolor(lowcolor and $f);
      textbackground(lowcolor shr 4);
{$endif}
    end
  else
    xwritess(#27,'[m');
end;

procedure xwritehighlights(s: string);

var
  i: integer;

begin
  for i := 1 to length(s) do
    if s[i]='<' then
      xhighvideo
    else if s[i]='>' then
      xlowvideo
    else
      xwrites(s[i]);
end;

{serio:  procedures end}

{serio.pas ends}